home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / xlibpas2.zip / XBMP2.PAS < prev    next >
Pascal/Delphi Source File  |  1994-06-12  |  4KB  |  182 lines
  1. unit XBMP2;
  2. { ************************************************
  3.   **    BMP Decoding and Encoding procedures    **
  4.   **        for Borland/Turbo Pascal 7.0        **
  5.   **                                            **
  6.   **     Written by Tristan Tarrant, 1994       **
  7.   **                                            **
  8.   ************************************************ }
  9.  
  10. interface
  11.  
  12. uses
  13.     Dos;
  14.  
  15. type
  16.     BMPLineProcType = procedure( Var pixels; line, width : integer );
  17.     BMPPixelProcType = function( x, y : integer) : integer;
  18.     TByteArray = Array[0..0] of byte;
  19.     TIntArray = Array[0..0] of integer;
  20.  
  21. Var
  22.     { Pointers to custom procedures to deal with lines. BMPOutLineProc
  23.       is called with three parameters : an untyped var, containing
  24.       the uncompressed data, and two integer values, containing the
  25.       line number and the width of the line.
  26.       BMPInPixelProc should instead return a pixels value, -1 if at the
  27.       end of the data. }
  28.  
  29.     BMPOutLineProc : BMPLineProcType;
  30.     BMPInPixelProc : BMPPixelProcType;
  31.     BMPPalette : array[0..767] of byte;
  32.  
  33. function SaveBMP( f : string; width, depth : integer; var palette ) : boolean;
  34. function LoadBMP( f : string ) : boolean;
  35.  
  36. implementation
  37.  
  38. type
  39.     BMPHeader = record
  40.         id : array[1..2] of char;
  41.         filesize,
  42.         reserved,
  43.         headersize,
  44.         infoSize,
  45.         wid,
  46.         hgt : longint;
  47.         biPlanes, bits : integer;
  48.         biCompression,
  49.         biSizeImage,
  50.         biXPelsPerMeter,
  51.         biYPelsPerMeter,
  52.         biClrUsed,
  53.         biClrImportant : longint;
  54.     end;
  55.  
  56.     BMPRGB = record
  57.         b, g, r, f : byte;
  58.     end;
  59.  
  60. function DecodeBMP( var f : file ) : boolean;
  61. var
  62.     BMPHead : BMPHeader;
  63.     hgt, wid, index : integer;
  64.     r, g, b : byte;
  65.     ScreenLine : pointer;
  66.     col : BMPRGB;
  67.  
  68. begin
  69.     blockread( f, BMPHead, SizeOf( BMPHead ) );
  70.     for index:=0 to 255 do
  71.     begin
  72.         blockread( f, col, SizeOf( BMPRGB ) );
  73.         BMPPalette[index*3] := col.r shr 2;
  74.         BMPPalette[index*3+1] := col.g shr 2;
  75.         BMPPalette[index*3+2] := col.b shr 2;
  76.     end;
  77.     wid := BMPHead.wid;
  78.     if wid mod 4<>0 then wid := wid + 4 - wid mod 4;
  79.     GetMem( ScreenLine, wid );
  80.     hgt := BMPHead.hgt-1;
  81.     for index:=hgt downto 0 do
  82.     begin
  83.         blockread( f, ScreenLine^, wid );
  84.         BMPOutLineProc( ScreenLine^, index, wid );
  85.     end;
  86.     DecodeBMP := true;
  87. end;
  88.  
  89. function LoadBMP( F : string ) : boolean;
  90. var
  91.     D: DirStr;
  92.     N: NameStr;
  93.     E: ExtStr;
  94.     FileHandle : File;
  95. begin
  96.     FSplit( F, D, N, E );
  97.     if E='' then E:='.BMP';
  98.     F := D+N+E;
  99.     {$I-}
  100.         assign( FileHandle, F );
  101.         reset( FileHandle, 1 );
  102.     {$I+}
  103.     if ioresult = 0 then
  104.         LoadBMP := DecodeBMP( FileHandle )
  105.     else
  106.         LoadBMP := false;
  107.     {$I-}
  108.         close( FileHandle );
  109.     {$I+}
  110. end; { LoadBMP }
  111.  
  112. function EncodeBMP( var f : file; width, depth : integer; var palette ) : boolean;
  113. var
  114.     BMPHead : BMPHeader;
  115.     hgt, wid, index, index2 : integer;
  116.     r, g, b : byte;
  117.     ScreenLine : pointer;
  118.     col : BMPRGB;
  119.     ThePalette : TByteArray absolute palette;
  120.  
  121. begin
  122.     fillchar( BMPHead, sizeof(BMPHeader),0 );
  123.     with BMPHead do
  124.     begin
  125.         id := 'BP';
  126.         headersize := 1078;
  127.         filesize := headersize + width*depth;
  128.         wid := width;
  129.         hgt := depth;
  130.         infosize := $28;
  131.         bits := 8;
  132.         biplanes := 1;
  133.         biCompression := 0;
  134.     end;
  135.  
  136.     blockwrite( f, BMPHead, SizeOf( BMPHead ) );
  137.     for index:=0 to 255 do
  138.     begin
  139.         col.r := ThePalette[index*3] shl 2;
  140.         col.g := ThePalette[index*3+1] shl 2;
  141.         col.b := ThePalette[index*3+2] shl 2;
  142.         blockwrite( f, col, SizeOf( BMPRGB ) );
  143.     end;
  144.     wid := width;
  145.     if wid mod 4<>0 then wid := wid + 4 - wid mod 4;
  146.     GetMem( ScreenLine, wid );
  147.     hgt := BMPHead.hgt-1;
  148.     for index:=hgt downto 0 do
  149.     begin
  150.         fillchar( ScreenLine^,wid,0);
  151.         for index2 := 0 to width-1 do
  152.             TByteArray(ScreenLine^)[index2] := BMPInPixelProc(index2,index);
  153.         blockwrite( f, ScreenLine^, wid );
  154.     end;
  155.     EncodeBMP := true;
  156. end;
  157.  
  158. function SaveBMP( f : string; width, depth : integer; var palette ) : boolean;
  159. var
  160.     D: DirStr;
  161.     N: NameStr;
  162.     E: ExtStr;
  163.     FileHandle : File;
  164. begin
  165.     FSplit( F, D, N, E );
  166.     if E='' then E:='.BMP';
  167.     F := D+N+E;
  168.     {$I-}
  169.         assign( FileHandle, F );
  170.         rewrite( FileHandle, 1 );
  171.     {$I+}
  172.     if ioresult = 0 then
  173.         SaveBMP := EncodeBMP( FileHandle, width, depth, palette )
  174.     else
  175.         SaveBMP := false;
  176.     {$I-}
  177.         close( FileHandle );
  178.     {$I+}
  179. end;
  180.  
  181. end.
  182.